home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_gimp.idb / usr / freeware / share / gimp / scripts / hsv-graph.scm.z / hsv-graph.scm
Encoding:
GIMP Script-Fu Script  |  1999-07-21  |  12.3 KB  |  353 lines
  1. ;;; hsv-graph.scm -*-scheme-*-
  2. ;;; Author: Shuji Narazaki <narazaki@InetQ.or.jp>
  3. ;;; Time-stamp: <1998/01/18 05:25:03 narazaki@InetQ.or.jp>
  4. ;;; Version: 1.2
  5. ;;; Code:
  6.  
  7. (if (not (symbol-bound? 'script-fu-hsv-graph-scale (the-environment)))
  8.     (define script-fu-hsv-graph-scale 1))
  9. (if (not (symbol-bound? 'script-fu-hsv-graph-opacity (the-environment)))
  10.     (define script-fu-hsv-graph-opacity 100))
  11. (if (not (symbol-bound? 'script-fu-hsv-graph-bounds? (the-environment)))
  12.     (define script-fu-hsv-graph-bounds? TRUE))
  13. (if (not (symbol-bound? 'script-fu-hsv-graph-left2right? (the-environment)))
  14.     (define script-fu-hsv-graph-left2right? FALSE))
  15. (if (not (symbol-bound? 'script-fu-hsv-graph-beg-x (the-environment)))
  16.     (define script-fu-hsv-graph-beg-x 0))
  17. (if (not (symbol-bound? 'script-fu-hsv-graph-beg-y (the-environment)))
  18.     (define script-fu-hsv-graph-beg-y 0))
  19. (if (not (symbol-bound? 'script-fu-hsv-graph-end-x (the-environment)))
  20.     (define script-fu-hsv-graph-end-x 1))
  21. (if (not (symbol-bound? 'script-fu-hsv-graph-end-y (the-environment)))
  22.     (define script-fu-hsv-graph-end-y 1))
  23.  
  24. (define (script-fu-hsv-graph img drawable scale opacity bounds?
  25.                  left2right? beg-x beg-y end-x end-y)
  26.   (define (floor x) (- x (fmod x 1)))
  27.   (define *pos* #f)
  28.   (define (set-point! fvec index x y)
  29.     (aset fvec (* 2 index) x)
  30.     (aset fvec (+ (* 2 index) 1) y)
  31.     fvec)
  32.  
  33.   (define (plot-dot img drawable x y)
  34.     (gimp-pencil img drawable 1 (set-point! *pos* 0 x y)))
  35.  
  36.   (define (rgb-to-hsv rgb hsv)
  37.     (let* ((red (floor (nth 0 rgb)))
  38.        (green (floor (nth 1 rgb)))
  39.        (blue (floor (nth 2 rgb)))
  40.        (h 0.0)
  41.        (s 0.0)
  42.        (minv (min red (min green blue)))
  43.        (maxv (max red (max green blue)))
  44.        (v maxv)
  45.        (delta 0))
  46.       (if (not (= 0 maxv))
  47.       (set! s (/ (* (- maxv minv) 255.0) maxv))
  48.       (set! s 0.0))
  49.       (if (= 0.0 s)
  50.       (set! h 0.0)
  51.       (begin
  52.         (set! delta (- maxv minv))
  53.         (cond ((= maxv red)
  54.            (set! h (/ (- green blue) delta)))
  55.           ((= maxv green)
  56.            (set! h (+ 2.0 (/ (- blue red) delta))))
  57.           ((= maxv blue)
  58.            (set! h (+ 4.0 (/ (- red green) delta)))))
  59.         (set! h (* 42.5 h))
  60.         (if (< h 0.0)
  61.         (set! h (+ h 255.0)))
  62.         (if (< 255 h)
  63.         (set! h (- h 255.0)))))
  64.       (set-car! hsv (floor h))
  65.       (set-car! (cdr hsv) (floor s))
  66.       (set-car! (cddr hsv) (floor v))))
  67.  
  68.   ;; segment is
  69.   ;;   filled-index (integer)
  70.   ;;   size as number of points (integer)
  71.   ;;   vector (which size is 2 * size)
  72.   (define (make-segment length x y)
  73.     (if (< 64 length)
  74.     (set! length 64))
  75.     (if (< length 5)
  76.     (set! length 5))
  77.     (let ((vec (cons-array (* 2 length) 'double)))
  78.       (aset vec 0 x)
  79.       (aset vec 1 y)
  80.       (list 1 length vec)))
  81.  
  82.   ;; accessors
  83.   (define (segment-filled-size segment) (car segment))
  84.   (define (segment-max-size segment) (cadr segment))
  85.   (define (segment-strokes segment) (caddr segment))
  86.  
  87.   (define (fill-segment! segment new-x new-y)
  88.     (define (shift-segment! segment)
  89.       (let ((base 0)
  90.         (size (cadr segment))
  91.         (vec (caddr segment))
  92.         (offset 2))
  93.     (while (< base offset)
  94.            (aset vec (* 2 base)
  95.              (aref vec (* 2 (- size (- offset base)))))
  96.            (aset vec (+ (* 2 base) 1)
  97.              (aref vec (+ (* 2 (- size (- offset base))) 1)))
  98.            (set! base (+ base 1)))
  99.     (set-car! segment base)))  
  100.     (let ((base (car segment))
  101.       (size (cadr segment))
  102.       (vec (caddr segment)))
  103.       (if (= base 0)
  104.       (begin
  105.         (shift-segment! segment)
  106.         (set! base (segment-filled-size segment))))
  107.       (if (and (= new-x (aref vec (* 2 (- base 1))))
  108.            (= new-y (aref vec (+ (* 2 (- base 1)) 1))))
  109.       #f
  110.       (begin
  111.         (aset vec (* 2 base) new-x)
  112.         (aset vec (+ (* 2 base) 1) new-y)
  113.         (set! base (+ base 1))
  114.         (if (= base size)
  115.         (begin
  116.           (set-car! segment 0)
  117.           #t)
  118.         (begin
  119.           (set-car! segment base)
  120.           #f))))))
  121.  
  122.   (define (draw-segment img drawable segment limit rgb)
  123.     (gimp-palette-set-foreground rgb)
  124.     (gimp-airbrush img drawable 100 (* 2 limit) (segment-strokes segment)))
  125.  
  126.   (define red-color '(255 10 10))
  127.   (define green-color '(10 255 10))
  128.   (define blue-color '(10 10 255))
  129.   (define hue-segment #f)
  130.   (define saturation-segment #f)
  131.   (define value-segment #f)
  132.   (define red-segment #f)
  133.   (define green-segment #f)
  134.   (define blue-segment #f)
  135.   (define border-size 10)
  136.  
  137.   (define (fill-dot img drawable x y segment color)
  138.     (if (fill-segment! segment x y)
  139.     (begin
  140.       (gimp-palette-set-foreground color)    
  141.       (draw-segment img drawable segment (segment-max-size segment) color)
  142.       #t)
  143.     #f))
  144.  
  145.   (define (fill-color-band img drawable x scale x-base y-base color)
  146.     (gimp-palette-set-foreground color)
  147.     (gimp-rect-select img (+ x-base (* scale x)) 0 scale y-base REPLACE FALSE 0)
  148.     (gimp-bucket-fill img drawable FG-BUCKET-FILL NORMAL 100 0 FALSE 0 0)
  149.     (gimp-selection-none img))
  150.  
  151.   (define (plot-hsv img drawable x scale x-base y-base hsv)
  152.     (let ((real-x (* scale x))
  153.       (h (car hsv))
  154.       (s (cadr hsv))
  155.       (v (caddr hsv)))
  156.       (fill-dot img drawable (+ x-base real-x) (- y-base h)
  157.         hue-segment red-color)
  158.       (fill-dot img drawable (+ x-base real-x) (- y-base s)
  159.         saturation-segment green-color)
  160.       (if (fill-dot img drawable (+ x-base real-x) (- y-base v)
  161.             value-segment blue-color)
  162.       (gimp-displays-flush))))
  163.  
  164.   (define (plot-rgb img drawable x scale x-base y-base hsv)
  165.     (let ((real-x (* scale x))
  166.       (h (car hsv))
  167.       (s (cadr hsv))
  168.       (v (caddr hsv)))
  169.       (fill-dot img drawable (+ x-base real-x) (- y-base h)
  170.         red-segment red-color)
  171.       (fill-dot img drawable (+ x-base real-x) (- y-base s)
  172.         green-segment green-color)
  173.       (if (fill-dot img drawable (+ x-base real-x) (- y-base v)
  174.             blue-segment blue-color)
  175.       (gimp-displays-flush))))
  176.  
  177.   (define (clamp-value x minv maxv)
  178.     (if (< x minv)
  179.     (set! x minv))
  180.     (if (< maxv x)
  181.     (set! x maxv))
  182.     x)
  183.  
  184.   ;; start of script-fu-hsv-graph
  185.   (if (= TRUE bounds?)
  186.       (if (= TRUE (car (gimp-selection-bounds img)))
  187.       (let ((results (gimp-selection-bounds img)))
  188.         (set! beg-x (nth (if (= TRUE left2right?) 1 3) results))
  189.         (set! beg-y (nth 2 results))
  190.         (set! end-x (nth (if (= TRUE left2right?) 3 1) results))
  191.         (set! end-y (nth 4 results)))
  192.       (let ((offsets (gimp-drawable-offsets drawable)))
  193.         (set! beg-x (if (= TRUE left2right?)
  194.                 (nth 0 offsets)
  195.                 (- (+ (nth 0 offsets)
  196.                   (car (gimp-drawable-width drawable)))
  197.                    1)))
  198.         (set! beg-y (nth 1 offsets))
  199.         (set! end-x (if (= TRUE left2right?)
  200.                 (- (+ (nth 0 offsets)
  201.                   (car (gimp-drawable-width drawable)))
  202.                    1)
  203.                 (nth 0 offsets)))
  204.         (set! end-y (- (+ (nth 1 offsets)
  205.                   (car (gimp-drawable-height drawable)))
  206.                1))))
  207.       (let ((offsets (gimp-drawable-offsets drawable)))
  208.     (set! beg-x (clamp-value beg-x 0
  209.                  (+ (nth 0 offsets)
  210.                     (gimp-drawable-width drawable))))
  211.     (set! end-x (clamp-value end-x 0 
  212.                  (+ (nth 0 offsets)
  213.                     (gimp-drawable-width drawable))))
  214.     (set! beg-y (clamp-value beg-y 0 
  215.                  (+ (nth 1 offsets)
  216.                     (gimp-drawable-height drawable))))
  217.     (set! end-y (clamp-value beg-y 0
  218.                  (+ (nth 1 offsets)
  219.                     (gimp-drawable-height drawable))))))
  220.   (set! opacity (clamp-value opacity 0 100))
  221.   (let* ((x-len (- end-x beg-x))
  222.      (y-len (- end-y beg-y))
  223.      (limit (pow (+ (pow x-len 2) (pow y-len 2)) 0.5))
  224.      (gimg-width (* limit scale))
  225.      (gimg-height 256)
  226.      (gimg (car (gimp-image-new (+ (* 2 border-size) gimg-width)
  227.                     (+ (* 2 border-size) gimg-height) RGB)))
  228.      (bglayer (car (gimp-layer-new gimg
  229.                        (+ (* 2 border-size) gimg-width)
  230.                        (+ (* 2 border-size) gimg-height)
  231.                        1 "Background" 100 NORMAL)))
  232.      (hsv-layer (car (gimp-layer-new gimg
  233.                        (+ (* 2 border-size) gimg-width)
  234.                        (+ (* 2 border-size) gimg-height)
  235.                       RGBA_IMAGE "HSV Graph" 100 NORMAL)))
  236.      (rgb-layer (car (gimp-layer-new gimg
  237.                        (+ (* 2 border-size) gimg-width)
  238.                        (+ (* 2 border-size) gimg-height)
  239.                       RGBA_IMAGE "RGB Graph" 100 NORMAL)))
  240.      (clayer (car (gimp-layer-new gimg gimg-width 40 RGBA_IMAGE
  241.                        "Color Sampled" opacity NORMAL)))
  242.      (rgb '(255 255 255))
  243.      (hsv '(254 255 255))
  244.      (x-base border-size)
  245.      (y-base (+ gimg-height border-size))
  246.      (index 0)
  247.      (old-foreground (car (gimp-palette-get-foreground)))
  248.      (old-background (car (gimp-palette-get-background)))
  249.      (old-paint-mode (car (gimp-brushes-get-paint-mode)))
  250.      (old-brush (car (gimp-brushes-get-brush)))
  251.      (old-opacity (car (gimp-brushes-get-opacity))))
  252.     (gimp-image-disable-undo gimg)
  253.     (gimp-image-add-layer gimg bglayer -1)
  254.     (gimp-selection-all gimg)
  255.     (gimp-palette-set-background '(255 255 255))
  256.     (gimp-edit-fill gimg bglayer)
  257.     (gimp-image-add-layer gimg hsv-layer -1)
  258.     (gimp-edit-clear gimg hsv-layer)
  259.     (gimp-image-add-layer gimg rgb-layer -1)
  260.     (gimp-layer-set-visible rgb-layer FALSE)
  261.     (gimp-edit-clear gimg rgb-layer)
  262.     (gimp-image-add-layer gimg clayer -1)
  263.     (gimp-edit-clear gimg clayer)
  264.     (gimp-layer-translate clayer border-size 0)
  265.     (gimp-selection-none gimg)
  266.     (set! red-segment (make-segment 64 x-base y-base))
  267.     (set! green-segment (make-segment 64 x-base y-base))
  268.     (set! blue-segment (make-segment 64 x-base y-base))
  269.     (set! hue-segment (make-segment 64 x-base y-base))
  270.     (set! saturation-segment (make-segment 64 x-base y-base))
  271.     (set! value-segment (make-segment 64 x-base y-base))
  272.     (gimp-brushes-set-brush "Circle (01)")
  273.     (gimp-brushes-set-paint-mode NORMAL)
  274.     (gimp-brushes-set-opacity 70)
  275.     (gimp-display-new gimg)
  276.     (while (< index limit)
  277.       (set! rgb (car (gimp-color-picker img drawable
  278.                     (+ beg-x (* x-len (/ index limit)))
  279.                     (+ beg-y (* y-len (/ index limit)))
  280.                     TRUE FALSE)))
  281.       (fill-color-band gimg clayer index scale x-base 40 rgb)
  282.       (rgb-to-hsv rgb hsv)
  283.       (plot-hsv gimg hsv-layer index scale x-base y-base hsv)
  284.       (plot-rgb gimg rgb-layer index scale x-base y-base rgb)
  285.       (set! index (+ index 1)))
  286.     (mapcar
  287.      (lambda (segment color)
  288.        (if (< 1 (segment-filled-size segment))
  289.     (begin 
  290.       (gimp-palette-set-foreground color)
  291.       (draw-segment gimg hsv-layer segment (segment-filled-size segment)
  292.             color))))
  293.      (list hue-segment saturation-segment value-segment)
  294.      (list red-color green-color blue-color))
  295.     (mapcar
  296.      (lambda (segment color)
  297.        (if (< 1 (segment-filled-size segment))
  298.     (begin 
  299.       (gimp-palette-set-foreground color)
  300.       (draw-segment gimg rgb-layer segment (segment-filled-size segment)
  301.             color))))
  302.      (list red-segment green-segment blue-segment)
  303.      (list red-color green-color blue-color))
  304.     (gimp-palette-set-foreground '(255 255 255))
  305.     (let ((text-layer (car (gimp-text gimg -1 0 0 
  306.                       "Red: Hue, Green: Sat, Blue: Val"
  307.                       1 1 12 PIXELS "*" 
  308.                       "helvetica" "*" "*" "*" "*")))
  309.       (offset-y (- y-base (car (gimp-drawable-height clayer)))))
  310.       (gimp-layer-set-mode text-layer DIFFERENCE)
  311.       (gimp-layer-translate clayer 0 offset-y)
  312.       (gimp-layer-translate text-layer border-size (+ offset-y 15)))
  313.     (gimp-image-set-active-layer gimg bglayer)
  314.     (gimp-image-clean-all gimg)
  315.     ;; return back the state
  316.     (gimp-palette-set-foreground old-foreground)
  317.     (gimp-palette-set-foreground old-background)
  318.     (gimp-brushes-set-brush old-brush)
  319.     (gimp-brushes-set-paint-mode old-paint-mode)
  320.     (gimp-brushes-set-opacity old-opacity)
  321.     (gimp-image-enable-undo gimg)
  322.     (set! script-fu-hsv-graph-scale scale)
  323.     (set! script-fu-hsv-graph-opacity opacity)
  324.     (set! script-fu-hsv-graph-bounds? bounds?)
  325.     (set! script-fu-hsv-graph-left2right? left2right?)
  326.     (set! script-fu-hsv-graph-beg-x beg-x)
  327.     (set! script-fu-hsv-graph-beg-y beg-y)
  328.     (set! script-fu-hsv-graph-end-x end-x)
  329.     (set! script-fu-hsv-graph-end-y end-y)
  330.     (gimp-displays-flush)))
  331.  
  332. (script-fu-register
  333.  "script-fu-hsv-graph"
  334.  "<Image>/Script-Fu/Utils/Draw HSV Graph"
  335.  "Draph the graph of H/S/V values on the drawable"
  336.  "Shuji Narazaki <narazaki@InetQ.or.jp>"
  337.  "Shuji Narazaki"
  338.  "1997"
  339.  "RGB*"
  340.  SF-IMAGE "Image to analyze" 0
  341.  SF-DRAWABLE "Drawable to analyze" 0
  342.  SF-VALUE "Graph Scale" (number->string script-fu-hsv-graph-scale)
  343.  SF-VALUE "BG Opacity" (number->string script-fu-hsv-graph-opacity)
  344.  SF-TOGGLE "Use Selection Bounds instead of belows" script-fu-hsv-graph-bounds?
  345.  SF-TOGGLE "from Top-Left to Bottom-Right" script-fu-hsv-graph-left2right?
  346.  SF-VALUE "Start X" (number->string script-fu-hsv-graph-beg-x)
  347.  SF-VALUE "Start Y" (number->string script-fu-hsv-graph-beg-y)
  348.  SF-VALUE "End X" (number->string script-fu-hsv-graph-end-x)
  349.  SF-VALUE "End Y" (number->string script-fu-hsv-graph-end-y)
  350. )
  351.  
  352. ;;; hsv-graph.scm ends here
  353.